home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / regions.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  25KB  |  673 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; Regions
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '( region
  24.       make-region
  25.       copy-region
  26.       region-clip-box
  27.       region-x
  28.       region-y
  29.       region-width
  30.       region-height
  31.       region-x ;; SETF'able
  32.       region-y ;; SETF'able
  33.       region-empty-p
  34.       region-intersection
  35.       region-union
  36.       region-subtract
  37.       point-in-region-p
  38.       region-equal
  39.       subregion-p
  40.       region-intersect-p
  41.       map-region
  42.       region->image
  43.       IMAGE->REGION ;; not implemented
  44.       POLYGON-REGION ;; not implemented
  45.       ))
  46.  
  47. ;;; Regions are arbitrary collections of pixels.  This is represented
  48. ;;; in the region structure as either a list of rectangles or a bitmap.
  49.  
  50. (defstruct (region (:constructor create-region) (:conc-name region-)
  51.            (:predicate region-p)
  52.            (:copier copy-region-structure)
  53.            #+ti (:callable-constructors nil))
  54.   (left   0 :type integer)
  55.   (top    0 :type integer)
  56.   (right  0 :type integer)
  57.   (bottom 0 :type integer)
  58.   (next nil)
  59.   )
  60.  
  61. ;;; NOTE: This is inefficient.  Should be:
  62. #|
  63. (defstruct (rectangle #+ti (:callable-constructors nil))
  64.   (left   0 :type integer)
  65.   (top    0 :type integer)
  66.   (right  0 :type integer)
  67.   (bottom 0 :type integer)
  68.   )
  69.  
  70. (defstruct (region (:include rectangle)        ;; Bounding rectangle
  71.                (:constructor create-region)
  72.            (:copier copy-region-structure)
  73.            #+ti (:callable-constructors nil))
  74.   (elements nil)        ;; A list of rectangles or a bitmap
  75.   (plist nil :type list)
  76.   )
  77. |#
  78.  
  79. (defun make-region (&optional x y width height)
  80.   ;; With no parameters, returns an empty region
  81.   ;; If some parameters are given, all must be given.
  82.   (declare (type (or null int16) x y width height)
  83.        (values region))
  84.   (if x
  85.       (create-region :left x :top y :right (+ x width) :bottom (+ y height))
  86.     (create-region)))
  87.  
  88. (defun copy-region (region)
  89.   (let ((new (copy-region-structure region))
  90.     (next (region-next region)))
  91.     (when next
  92.       (setf (region-next new)
  93.         (copy-region next)))
  94.     new))
  95.  
  96. ;; Accessors that return the boundaries of a region
  97. (defun region-x (region)
  98.   (declare (type region region)
  99.        (values integer))
  100.   ;; Loop over regions
  101.   (do ((reg (region-next region) (region-next reg))
  102.        (top (region-top region)))
  103.       ((null reg) top)
  104.     (setq top (min top (region-top reg)))))
  105.  
  106. (defun region-y (region)
  107.   (declare (type region region)
  108.        (values integer))
  109.   ;; Loop over regions
  110.   (do ((reg (region-next region) (region-next reg))
  111.        (left (region-left region)))
  112.       ((null reg) left)
  113.     (setq left (min left (region-left reg)))))
  114.  
  115. (defun region-width (region)
  116.   (declare (type region region)
  117.        (values integer))
  118.   ;; Loop over regions
  119.   (do ((reg (region-next region) (region-next reg))
  120.        (left (region-left region))
  121.        (right (region-right region)))
  122.       ((null reg) (- right left))
  123.     (setq left (min left (region-left reg))
  124.       right (max right (region-right reg)))))
  125.     
  126. (defun region-height (region)
  127.   (declare (type region region)
  128.        (values integer))
  129.   ;; Loop over regions
  130.   (do ((reg (region-next region) (region-next reg))
  131.        (top (region-top region))
  132.        (bottom (region-bottom region)))
  133.       ((null reg) (- bottom top))
  134.     (setq top (min top (region-top reg))
  135.       bottom (max bottom (region-bottom reg)))))
  136.  
  137. (defsetf region-x set-region-x)
  138. (defsetf region-y set-region-y)
  139. ;; Setting a region's X/Y translates the region
  140.  
  141. (defun set-region-x (region value)
  142.   (declare (type region region)
  143.        (values integer))
  144.   ;; Loop over regions
  145.   (do ((delta (- value (region-x region)))
  146.        (reg region (region-next region)))
  147.       ((null reg) value)
  148.     (incf (region-left reg) delta)
  149.     (incf (region-right reg) delta)))
  150.  
  151. (defun set-region-y (region value)
  152.   (declare (type region region)
  153.        (values integer))
  154.   ;; Loop over regions
  155.   (do ((delta (- value (region-y region)))
  156.        (reg region (region-next region)))
  157.       ((null reg) value)
  158.     (incf (region-top reg) delta)
  159.     (incf (region-bottom reg) delta)))
  160.  
  161. (defun region-empty-p (region)
  162.   (declare (type region region)
  163.        (values boolean))
  164.   ;; Loop over regions
  165.   (do ((reg region (region-next reg)))
  166.       ((null reg) t)
  167.     (declare (type (or null region) reg))
  168.     (unless (and (= (region-left reg) (region-right reg))
  169.          (= (region-top reg) (region-bottom reg)))
  170.       (return nil))))
  171.  
  172. (defun region-clip-box (&rest regions)
  173.   "Returns a region which is the smallest enclosing rectangle enclosing REGIONS
  174.  Returns the empty region if no regions are given."
  175.   (declare (type list regions) ;; (list region)
  176.        (values region))
  177.   (let ((result (create-region))
  178.     (first-region (car regions)))
  179.     (DECLARE (TYPE region result)
  180.          (TYPE (OR null region) first-region))
  181.     (when first-region
  182.       (let ((left   (region-left first-region))
  183.         (right  (region-right first-region))
  184.         (top    (region-top first-region))
  185.         (bottom (region-bottom first-region)))
  186.     (DECLARE (TYPE integer left right top bottom))
  187.     (dolist (region regions)
  188.       (declare (type region region))
  189.       (do ((reg region (region-next region)))
  190.           ((null reg))
  191.         (declare (type (or null region) reg))
  192.         (unless (eq reg first-region)
  193.           (setq left   (min left   (region-left   region))
  194.             top    (min top    (region-top    region))
  195.             right  (max right  (region-right  region))
  196.             bottom (max bottom (region-bottom region))))))
  197.     (setf (region-left   result) left
  198.           (region-right  result) right
  199.           (region-top    result) top
  200.           (region-bottom result) bottom)))
  201.     result))
  202.  
  203. (defun region-intersection (&rest regions)
  204.   "Returns a region which is the intersection of one or more REGIONS.
  205. Returns an empty region if the intersection is empty.
  206. If there are no regions given, return a very large region."
  207.   (declare (type list regions) ;; (list region)
  208.        (values region))
  209.   (IF regions
  210.       (LET ((result nil))
  211.     (do ((region regions (CDR region)))
  212.         ((NULL (CDR region))
  213.          (OR result (create-region)))
  214.       (do ((region1 (FIRST region) (region-next region1)))
  215.           ((null region1))
  216.         (DOLIST (reg2 (CDR region))
  217.           (DO ((region2 reg2 (region-next region2)))
  218.           ((NULL region2))
  219.         (WHEN (NOT (OR (<= (region-right  region2) (region-left region1))
  220.                    (<= (region-right  region1) (region-left region2))
  221.                    (<= (region-bottom region2) (region-top  region1))
  222.                    (<= (region-bottom region1) (region-top  region2))))
  223.           (SETQ result
  224.             (region-nconc-rectangle
  225.               result
  226.               (MAX (region-left   region1) (region-left   region2))
  227.               (MAX (region-top    region1) (region-top    region2))
  228.               (min (region-right  region1) (region-right  region2))
  229.               (min (region-bottom region1) (region-bottom region2))))))))))
  230.     (create-region :left most-negative-fixnum :top most-negative-fixnum
  231.            :right most-positive-fixnum :bottom :most-positive-fixnum)))
  232.  
  233. (defun region-subtract (region subtract)
  234.   "Returns a region containing the points that are in REGION but not in SUBTRACT"
  235.   (declare (type region region subtract)
  236.        (values region))
  237.   (do ((region-to-subtract subtract (region-next region-to-subtract))
  238.        (result nil))
  239.       ((null region-to-subtract) (or result (create-region)))
  240.     (do ((stop    (region-top    region-to-subtract))
  241.      (sleft   (region-left   region-to-subtract))
  242.      (sbottom (region-bottom region-to-subtract))
  243.      (sright  (region-right  region-to-subtract))
  244.      (region  region (region-next region)))
  245.     ((null region))
  246.       (let ((itop    (region-top    region))
  247.         (ileft   (region-left   region))
  248.         (ibottom (region-bottom region))
  249.         (iright  (region-right  region))
  250.         (intersect nil))
  251.     (when (not (or (<= iright sleft)
  252.                (<= sright ileft)))
  253.       (when (< itop stop ibottom)        ;TOP
  254.         ;; The regions in this case look like the following.
  255.         ;;         .-------------------.
  256.         ;;         |     intersect     |
  257.         ;;      .--+-------------------+--.
  258.         ;;      |  |                   |  |
  259.         ;;      |  |                   |  |
  260.         ;;      |  |                   |  |
  261.         ;;      |  `-------------------'  |
  262.         ;;      |                         |
  263.         ;;      |                         |
  264.         ;;      |        subtract         |
  265.         ;;      `-------------------------'
  266.         ;;
  267.         (setq intersect t)
  268.         (setq result (region-nconc-rectangle result ileft itop iright stop)))
  269.       (when (< itop sbottom ibottom)    ;BOTTOM
  270.         ;; The regions in this case look like the following.
  271.         ;;      .-------------------------.
  272.         ;;      |        subtract         |
  273.         ;;      |                         |
  274.         ;;      |                         |
  275.         ;;      |  .___________________.  |
  276.         ;;      |  |                   |  |
  277.         ;;      |  |                   |  |
  278.         ;;      |  |                   |  |
  279.         ;;      `--+-------------------+--'
  280.         ;;         |     intersect     |
  281.         ;;         `-------------------'
  282.         ;;
  283.         (setq intersect t)
  284.         (setq result (region-nconc-rectangle result ileft sbottom iright ibottom))))
  285.     (when (not (or (<= ibottom stop)
  286.                (<= sbottom itop)))
  287.       (when (< ileft sleft iright)        ;LEFT
  288.         ;; The regions in this case look like the following.
  289.         ;;                    .-----------------.
  290.         ;;                    |                 |
  291.         ;;      .-------------+----.            |
  292.         ;;      |             |    |            |
  293.         ;;      |             |    |            |
  294.         ;;      |  intersect  |    |  subtract  |
  295.         ;;      |             |    |            |
  296.         ;;      |             |    |            |
  297.         ;;      `-------------+----'            |
  298.         ;;                    |                 |
  299.         ;;                    `-----------------'
  300.         ;;
  301.         (setq intersect t)
  302.         (setq result (region-nconc-rectangle
  303.                result ileft (max itop stop) sleft (min ibottom sbottom))))
  304.       (when (< ileft sright iright)        ;RIGHT
  305.         ;; The regions in this case look like the following.
  306.         ;;      .-----------------.
  307.         ;;      |                 |
  308.         ;;      |            .----+-------------.
  309.         ;;      |            |    |             |
  310.         ;;      |            |    |             |
  311.         ;;      |  subtract  |    |  intersect  |
  312.         ;;      |            |    |             |
  313.         ;;      |            |    |             |
  314.         ;;      |            `----+-------------'
  315.         ;;      |                 |
  316.         ;;      `-----------------'
  317.         ;;
  318.         (setq intersect t)
  319.         (setq result (region-nconc-rectangle
  320.                result sright (max itop stop) iright (min ibottom sbottom)))))
  321.     (unless (or intersect            ;Save regions not split above
  322.             (and            ;Don't save regions covered by region-to-subtract
  323.               (>= ileft   sleft)
  324.               (>= itop    stop)
  325.               (<= iright  sright)
  326.               (<= ibottom sbottom)))
  327.         ;; The regions in this case do NOT look like the following.
  328.         ;;      .----------------------.
  329.         ;;      |      subtract        |
  330.         ;;      |                      |
  331.         ;;      |   .-------------.    |
  332.         ;;      |   |             |    |
  333.         ;;      |   |             |    |
  334.         ;;      |   |  intersect  |    |
  335.         ;;      |   |             |    |
  336.         ;;      |   |             |    |
  337.         ;;      |   `-------------'    |
  338.         ;;      |                      |
  339.         ;;      `----------------------'
  340.         ;;
  341.       (SETQ result (region-nconc-rectangle result ileft itop iright ibottom)))))))
  342.  
  343. ;; Internal function used by region-subtract and region-intersection
  344. (defun region-nconc-rectangle (region left top right bottom)
  345.   ;; Destructively modify REGION to include a rectangle
  346.   (DECLARE (type region region)
  347.        (type integer left top right bottom))
  348.   (do* ((reg1 (create-region :left left :top top :right right :bottom bottom :next region))
  349.     (previous reg1 reg2)
  350.     (reg2 (region-next reg1) (region-next reg2)))
  351.        ((null reg2) reg1)
  352.     (COND ((and (= left (region-left reg2))
  353.         (= right (region-right reg2)))
  354.        ;; left/right Edges line up.
  355.        ;; Check for region adjacent to top or bottom
  356.        (when
  357.          (cond ((= top (region-bottom reg2))
  358.             (SETQ top (setf (region-top reg1) (region-top reg2))))
  359.            ((= bottom (region-top reg2))
  360.             (SETQ bottom (setf (region-bottom reg1) (region-bottom reg2)))))
  361.          ;; Reg1 has been modified to include reg2. Splice out reg2
  362.          (setf (region-next previous) (region-next reg2))))
  363.       ((and (= top (region-top reg2))
  364.         (= bottom (region-bottom reg2)))
  365.        ;; top/bottom Edges line up.
  366.        ;; Check for region adjacent to left or right.
  367.        (when
  368.          (cond ((= left (region-right reg2))
  369.             (SETQ left (setf (region-left reg1) (region-left reg2))))
  370.            ((= right (region-left reg2))
  371.             (SETQ right (setf (region-right reg1) (region-right reg2)))))
  372.          ;; Reg1 has been modified to include reg2. Splice out reg2
  373.          (setf (region-next previous) (region-next reg2)))))))
  374.  
  375. (DEFUN union-regions (&rest regions)
  376.   ;; Append REGIONS, avoiding region fragmentation.
  377.   (APPLY 'nunion-regions (MAPCAR #'copy-region regions)))
  378.  
  379. (defun nunion-regions (&rest region-list)
  380.   ;; Append REGIONS, avoiding region fragmentation.
  381.   (DO* ((result (OR (CAR region-list) (create-region)))
  382.     (regions (CDR region-list) (CDR regions))
  383.     (nintersections 0)) ;; Number of intersections
  384.        ((ENDP regions)
  385.     (IF (> nintersections 1)
  386.         (unfragment-region result)
  387.       result))
  388.     (DECLARE (type region result)
  389.          (type list regions))
  390.     ;; Merge region with result
  391.     (DO* ((region (CAR regions))
  392.       (last nil reg1)            ; Loop over regions in result
  393.       (reg1 result (region-next reg1)))
  394.      ((NULL reg1)    ;; Link new regions into result
  395.       (SETF (region-next last) region))
  396.       (DECLARE (TYPE region region)
  397.            (TYPE (OR null region) last reg1))
  398.       (do* ((previous nil reg2)            ; Loop over new regions
  399.         (reg2 region (region-next reg2))
  400.         (left1 (region-left reg1))
  401.         (right1 (region-right reg1))
  402.         (top1 (region-top reg1))
  403.         (bottom1 (region-bottom reg1))
  404.         (left2) (right2)(top2)(bottom2))
  405.        ((null reg2))
  406.     (DECLARE (TYPE (OR null region) previous reg2))
  407.     (WHEN (and (> (SETQ right2 (region-right  reg2)) left1)
  408.            (> right1 (SETQ left2 (region-left reg2)))
  409.            (> (SETQ bottom2 (region-bottom reg2)) top1)
  410.            (> bottom1 (SETQ top2 (region-top  reg2))))
  411.       (INCF nintersections)
  412.       ;; regions intersect, merge them
  413.       
  414.       ;;
  415.       ;;      .----------------------.      .----------------------.
  416.       ;;      |          A           |      |   :             :    |
  417.       ;;      |~~~~-------------~~~~~|      |   .-------------.    |
  418.       ;;      |   |             |    |      |   |             |    |
  419.       ;;      |   |             |    |      |   |             |    |
  420.       ;;      |   |    Reg1     |    |      | C |     Reg1    |  D |
  421.       ;;      |   |             |    |      |   |             |    |
  422.       ;;      |   |             |    |      |   |             |    |
  423.       ;;      |~~~`-------------'~~~~|      |   `-------------'    |
  424.       ;;      |          B           |      |   :             :    |
  425.       ;;      `----------------------'      `----------------------'
  426.       ;;
  427.       (WHEN (> top1 top2)            ; Case A
  428.         (SETQ region  ;; Create extra region for portion of reg2 above reg1
  429.           (create-region
  430.             :next region
  431.             :left left2 :top top2 :right right2 :bottom top1))
  432.         (UNLESS previous (SETQ previous region))
  433.         (SETQ top2 (SETF (region-top reg2) top1)))
  434.       (WHEN (> bottom2 bottom1)        ; Case B
  435.         (SETQ region  ;; Create extra region for portion of reg2 below reg1
  436.           (create-region
  437.             :next region
  438.             :left left2 :top bottom1 :right right2 :bottom bottom2))
  439.         (UNLESS previous (SETQ previous region))
  440.         (SETQ bottom2 (SETF (region-bottom reg2) bottom1)))
  441.       (WHEN (> left1 left2)            ; Case C
  442.         (SETQ region  ;; Create extra region for portion of reg2 to the left of reg1
  443.           (create-region
  444.             :next region
  445.             :left left2 :top top2 :right left1 :bottom bottom2))
  446.         (UNLESS previous (SETQ previous region))
  447.         (SETQ left2 (SETF (region-left reg2) left1)))
  448.       (WHEN (> right2 right1)        ; Case D
  449.         (SETQ region  ;; Create extra region for portion of reg2 to the right of reg1
  450.           (create-region
  451.             :next region
  452.             :left right1 :top top2 :right right2 :bottom bottom2))
  453.         (UNLESS previous (SETQ previous region))
  454.         (SETQ right2 (SETF (region-right reg2) right1)))
  455.       ;; Check for reg2 INSIDE reg1
  456.       (when (and (>= left2 left1)
  457.          (>= top2 top1)
  458.          (<= right2 right1)
  459.          (<= bottom2 bottom1))
  460.         ;; Splice out reg2
  461.         (IF previous
  462.         (setf (region-next previous) (region-next reg2))
  463.           (SETQ region (region-next reg2)))))))))
  464.  
  465. (DEFUN unfragment-region (region)
  466.   ;; Regions sometimes get fragmented.  This function looks for
  467.   ;; two sub-regions within region that can be combined and
  468.   ;; destructively modifies the region to do the combination.
  469.   (loop 
  470.     (unless ;; Keep looping until no fragments found
  471.       (block success
  472.     (do ((reg1 region (region-next reg1)))
  473.         ((null reg1))
  474.       (do* ((left (region-left reg1))
  475.         (right (region-right reg1))
  476.         (top (region-top reg1))
  477.         (bottom (region-bottom reg1))
  478.         (previous reg1 reg2)
  479.         (reg2 (region-next reg1) (region-next reg2)))
  480.            ((null reg2))
  481.         (when (and (= left (region-left reg2))
  482.                (= right (region-right reg2)))
  483.           ;; left/right Edges line up.
  484.           ;; Check for region adjacent to top or bottom
  485.           (when
  486.         (cond ((= top (region-bottom reg2))
  487.                (setf (region-top reg1) (region-top reg2)))
  488.               ((= bottom (region-top reg2))
  489.                (setf (region-bottom reg1) (region-bottom reg2))))
  490.         ;; Reg1 has been modified to include reg2. Splice out reg2
  491.         (setf (region-next previous) (region-next reg2))
  492.         (return-from success t)))
  493.         (when (and (= top (region-top reg2))
  494.                (= bottom (region-bottom reg2)))
  495.           ;; top/bottom Edges line up.
  496.           ;; Check for region adjacent to left or right.
  497.           (when
  498.         (cond ((= left (region-right reg2))
  499.                (setf (region-left reg1) (region-left reg2)))
  500.               ((= right (region-left reg2))
  501.                (setf (region-right reg1) (region-right reg2))))
  502.         ;; Reg1 has been modified to include reg2. Splice out reg2
  503.         (setf (region-next previous) (region-next reg2))
  504.         (return-from success t))))))
  505.       (return region))))
  506.  
  507. (defun point-in-region-p (region x y)
  508.   ;; Returns T when X/Y are a point within REGION.
  509.   (declare (type region region)
  510.        (type int16 x y)
  511.        (values boolean))
  512.   ;; Loop over regions
  513.   (do ((reg region (region-next reg)))
  514.       ((NULL reg) nil)
  515.     (when (and (>= x (region-left  reg))
  516.            (>= y (region-top   reg))
  517.            (< x (region-right  reg))
  518.            (< y (region-bottom reg)))
  519.       (return t))))
  520.  
  521. ;; NOTE: NOT ROBUST WHEN A and B are fragmented differently *************
  522. (defun region-equal (a b)
  523.   ;; Returns T when regions a and b contain the same points.
  524.   ;; That is, return t when for every X/Y (point-in-region-p a x y)
  525.   ;; equals (point-in-region-p b x y)
  526.   (declare (type region a b)
  527.        (values boolean))
  528.   (do ((region1 a (region-next region1)))
  529.       ((null region1) t)
  530.     (let ((left (region-left region1))
  531.       (right (region-right region1))
  532.       (top (region-top region1))
  533.       (bottom (region-bottom region1)))
  534.       (do ((region2 b (region-next region2)))
  535.       ((null region2) (return-from region-equal nil))
  536.     (when (and (= left (region-left region2))
  537.            (= right (region-right region2))
  538.            (= top (region-top region2))
  539.            (= bottom (region-bottom region2)))
  540.       (return t))))))
  541.  
  542. ;; NOTE: NOT ROBUST WHEN LARGE and SMALL are fragmented differently *************
  543. (defun subregion-p (large small)
  544.   "Returns T if SMALL is within LARGE.
  545.  That is, return T when for every X/Y (point-in-region-p small X Y)
  546.  implies (point-in-region-p large X Y)."
  547.   (declare (type region large small)
  548.        (values boolean))
  549.   (do ((large-region large (region-next large-region)))
  550.       ((null large-region) nil)
  551.     (do ((small-region small (region-next small-region)))
  552.     ((null small-region) nil)
  553.       (when (and (>= (region-left   small-region) (region-left   large-region))
  554.          (>= (region-top    small-region) (region-top    large-region))
  555.          (<= (region-right  small-region) (region-right  large-region))
  556.          (<= (region-bottom small-region) (region-bottom large-region)))
  557.     (return-from subregion-p t)))))
  558.  
  559. (defun region-intersect-p (a b)
  560.   "Returns T if A intersects B.
  561.  That is, return T when there is some point common to regions A and B."
  562.   (declare (type region a b)
  563.        (values boolean))
  564.   (do ((region1 a (region-next region1)))
  565.       ((null region1) nil)
  566.     (let ((left (region-left region1))
  567.       (right (region-right region1))
  568.       (top (region-top region1))
  569.       (bottom (region-bottom region1)))
  570.       (do ((region2 b (region-next region2)))
  571.       ((null region2))
  572.     (when (and (> (region-right  region2) left)
  573.            (> right (region-left region2))
  574.            (> (region-bottom region2) top)
  575.            (> bottom (region-top  region2)))
  576.       (return-from region-intersect-p t))))))
  577.  
  578. (defun map-region (region function &rest args)
  579.   ;; Calls function with arguments (x y . args) for every point in REGION.
  580.   (declare (type region region)
  581.        (type function function))
  582.   (do ((reg region (region-next reg)))
  583.       ((null reg))
  584.     (do*  ((left (region-left reg))
  585.        (right (region-right reg))
  586.        (top (region-top reg))
  587.        (bottom (region-bottom reg))
  588.        (x left (1+ x)))
  589.       ((>= x right))
  590.       (do ((y top (1+ y)))
  591.       ((>= y bottom))
  592.     (apply function x y args)))))
  593.  
  594. (defun map-region-rectangles (region function &rest args)
  595.   ;; Calls function with arguments (x y width height . args) for every rectangle in REGION.
  596.   (declare (type region region)
  597.        (type function function))
  598.   (do ((reg region (region-next reg)))
  599.       ((null reg))
  600.     (let ((left (region-left reg))
  601.       (right (region-right reg))
  602.       (top (region-top reg))
  603.       (bottom (region-bottom reg)))
  604.       (apply function left top (- right left) (- bottom top) args))))
  605.  
  606. ;;   Why isn't it better to augment
  607. ;;   gcontext-clip-mask to deal with
  608. ;;       (or null (member :none) pixmap rect-seq region)
  609. ;;   and force conversions on the caller?
  610. ;; Good idea.
  611.  
  612. ;;(defun gcontext-clip-region (gcontext)
  613. ;;  ;; If the clip-mask of GCONTEXT is known, return it as a region.
  614. ;;  (declare (type gcontext gcontext)
  615. ;;       (values (or null region))))
  616.  
  617. ;;(defsetf gcontext-clip-region (gcontext) (region)
  618. ;;  ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include
  619. ;;  ;; only the pixels within REGION.
  620. ;;  (declare (type gcontext gcontext)
  621. ;;       (type region region)))
  622.  
  623. (DEFUN region-length (region &optional (limit 100))
  624.   ;; Debug function ***********
  625.   (DO ((reg region (region-next reg))
  626.        (n 0 (1+ n)))
  627.       ((NULL reg) n)
  628.     (WHEN (> n limit)
  629.       (ERROR "Region length longer than ~d" limit))))
  630.  
  631. #+comment
  632. (defun image->region (image)
  633.   ;; Returns a region containing the 1 bits of a depth-1 image
  634.   ;; Signals an error if image isn't of depth 1.
  635.   (declare (type image image)
  636.        (values region)))
  637.  
  638. (defun region->image (region)
  639.   ;; Returns a depth-1 image containg 1 bits for every pixel in REGION.
  640.   (declare (type region region)
  641.        (values image))
  642.   (let* ((box (region-clip-box region))
  643.      (width (region-width box))
  644.      (height (region-height box))
  645.      (next-p (region-next region))
  646.      (pixarray (make-array (list width height) :element-type 'bit
  647.                    :initial-contents (if next-p 0 1))))
  648.     (when next-p ;; Optimize for the rectangular case
  649.       (setf (region-x box) 0
  650.         (region-y box) 0)
  651.       (do ((reg region (region-next reg)))
  652.       ((null reg))
  653.     ;; There's gotta be a faster way...
  654.     (do*  ((left (region-left reg))
  655.            (right (region-right reg))
  656.            (top (region-top reg))
  657.            (bottom (region-bottom reg))
  658.            (x left (1+ x)))
  659.           ((>= x right))
  660.       (do ((y top (1+ y)))
  661.           ((>= y bottom))
  662.         (setf (aref pixarray y x) 1)))))
  663.     (create-image :width width
  664.           :height height
  665.           :depth 1
  666.           :data pixarray)))
  667.     
  668. #+comment
  669. (defun polygon-region (points &optional (fill-rule :even-odd))
  670.   (declare (type sequence points) ;(repeat-seq (integer x) (integer y))
  671.        (type (member :even-odd :winding) fill-rule)
  672.        (values region)))
  673.